home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Editors / emacs / Emacs-1.14b1 / lisp / mac / traps.el < prev    next >
Encoding:
Text File  |  1994-05-19  |  7.3 KB  |  247 lines  |  [TEXT/EMAC]
  1. ;;;
  2. ;;; This file is part of a Macintosh port of GNU Emacs.
  3. ;;; Copyright (C) 1993, 1994 Marc Parmet.  All rights reserved.
  4. ;;;
  5. ;;; GNU Emacs is distributed in the hope that it will be useful,
  6. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  7. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  8. ;;; GNU General Public License for more details.
  9. ;;;
  10.  
  11. ;;;
  12. ;;; This generates the Toolbox trap glue.
  13. ;;;
  14.  
  15. (defun gencode (words offset)
  16.   (if (null words)
  17.       nil
  18.     (cons
  19.      (list 'encode-internal 'mac-trap-code offset ''short (list 'hex-string-to-int (car words)))
  20.      (gencode (cdr words) (+ sizeof-short offset)))))
  21.  
  22. (defun munge-parameters (parameters)
  23.   (if (null parameters)
  24.       (list 0 nil nil nil)
  25.     (let* ((parameter (car parameters))
  26.            (name (nth 0 parameter))
  27.            (size (nth 1 parameter))
  28.            (register (nth 2 parameter))
  29.            (cdr-munge (munge-parameters (cdr parameters)))
  30.            (offset (nth 0 cdr-munge))
  31.            (cdr-stack (nth 1 cdr-munge))
  32.            (cdr-registers (nth 2 cdr-munge))
  33.            (cdr-names (nth 3 cdr-munge))
  34.            (target (if (eq size 'address)
  35.                        (` (let ((temp (, name)))
  36.                             (if (stringp temp) (string-data temp) temp)))
  37.                      name))
  38.            (typeparams (assoc size '((char 2 'char)
  39.                                      (short 2 'short)
  40.                                      (long 4 'long)
  41.                                      (address 4 'verbatim-long)
  42.                                      (immediate-string 4 'string))))
  43.            (offset-incr (nth 1 typeparams))
  44.            (type-code (nth 2 typeparams)))
  45.       (if register
  46.           (list
  47.            offset
  48.            cdr-stack
  49.            (` ((list (quote (, register)) (, target)) (,@ cdr-registers)))
  50.            (cons name cdr-names))
  51.         (list
  52.          (+ offset offset-incr)
  53.          (cons (` (encode-internal stack (, offset) (, type-code) (, target))) cdr-stack)
  54.          cdr-registers
  55.          (cons name cdr-names))))))
  56.        
  57. (defmacro deftrap (name code parameters return)
  58.   (let* ((code-retrieve (cond
  59.                          ((null return) nil)
  60.                          ((consp return) nil)
  61.                          ((eq return 'char) '("101f"))      ; move.b (a7)+,d0
  62.                          ((eq return 'short) '("301f"))      ; move.w (a7)+,d0
  63.                          ((eq return 'long) '("201f"))))  ; move.l (a7)+,d0
  64.          (code-rts (append code code-retrieve '("4e75"))) ; rts
  65.          (code-size (* 2 (length code-rts)))
  66.          (stack-result-size (cond ((null return) 0)
  67.                                   ((consp return) 0)
  68.                                   ((eq return 'char) 2)
  69.                                   ((eq return 'short) 2)
  70.                                   ((eq return 'long) 4)))
  71.          (munge-list (munge-parameters parameters))
  72.          (register-list (cons 'list (nth 2 munge-list)))
  73.          (stack-size (+ stack-result-size (nth 0 munge-list)))
  74.          (parameter-list (nth 3 munge-list))
  75.          (return-directive (cond ((null return) nil)
  76.                                  ((consp return) (list 'quote return))
  77.                                  ((eq return 'char) ''(char d0))
  78.                                  ((eq return 'short) ''(short d0))
  79.                                  ((eq return 'long) ''(long d0))))
  80.          (old-mac-trap-code-end mac-trap-code-end))
  81.     (if (> (+ mac-trap-code-end code-size) mac-trap-code-max)
  82.         (error "Out of code space for traps"))
  83.     (setq mac-trap-code-end (+ mac-trap-code-end code-size))
  84.     (` (progn
  85.          (if noninteractive
  86.              (message (concat "Defining trap " (, (symbol-name name)) "...")))
  87.          (,@ (gencode code-rts old-mac-trap-code-end))
  88.          (defun (, name) (, parameter-list)
  89.            (let ((stack (make-string (, stack-size) 0)))
  90.              (,@ (nth 1 munge-list))
  91.              (execute-68k-trap stack mac-trap-code (, old-mac-trap-code-end)
  92.                                (, register-list) (, return-directive))))))))
  93.  
  94. ;;;
  95. ;;; Below are traps that haven't yet been properly classfied into the right files.
  96. ;;;
  97.  
  98. (deftrap DebugStr-internal ("abff")
  99.   ((s address))
  100.   nil)
  101.  
  102. (defun DebugStr (&rest s)
  103.   (DebugStr-internal
  104.    (CtoPstr
  105.     (apply (function concat)
  106.        (mapcar (function (lambda (x)
  107.                    (if (stringp x) x
  108.                  (prin1-to-string x))))
  109.            s)))))
  110.  
  111. ;pascal OSErr NewAlias(const FSSpec *fromFile,
  112. ;               const FSSpec *target,
  113. ;               AliasHandle *alias)
  114. ;    = {0x7002,0xA823}; 
  115. (deftrap NewAlias ("7002" "a823")
  116.   ((fromFile address)
  117.    (toFile address)
  118.    (alias address))
  119.   short)
  120.  
  121. ;pascal OSErr NewAliasMinimal(const FSSpec *target,
  122. ;                  AliasHandle *alias)
  123. ;    = {0x7008,0xA823}; 
  124. (deftrap NewAliasMinimal ("7008" "a823")
  125.   ((target address)
  126.    (alias address))
  127.   short)
  128.  
  129. ;pascal OSErr NewAliasMinimalFromFullPath(short fullPathLength,
  130. ;                      const unsigned char *fullPath,
  131. ;                      ConstStr32Param zoneName,
  132. ;                      ConstStr31Param serverName,
  133. ;                      AliasHandle *alias)
  134. ;    = {0x7009,0xA823}; 
  135. (deftrap NewAliasMinimalFromFullPath ("7009" "a823")
  136.   ((fullPathLength short)
  137.    (fullPath address)
  138.    (zoneName address)
  139.    (serverName address)
  140.    (alias address))
  141.   short)
  142.  
  143. ;#pragma parameter BlockMove(__A0,__A1,__D0)
  144. ;pascal void BlockMove(const void *srcPtr,void *destPtr,Size byteCount)
  145. ;    = 0xA02E; 
  146. (deftrap BlockMove ("a02e")
  147.   ((srcPtr address a0)
  148.    (destPtr address a1)
  149.    (byteCount long d0))
  150.   nil)
  151.  
  152. ; #pragma parameter GetDateTime(__A0)
  153. ; pascal void GetDateTime(unsigned long *secs)
  154. ;    = {0x20B8,0x020C}; 
  155. (deftrap GetDateTime-internal ("20b8" "020c")
  156.   ((now address a0))
  157.   nil)
  158.  
  159. (defmacro GetDateTime (now)
  160.   (` (let ((s (make-string 4 0)))
  161.        (GetDateTime-internal s)
  162.        (setq (, now) (extract-internal s 0 'long)))))
  163.  
  164. ; pascal void StandardPutFile(ConstStr255Param prompt,
  165. ;                 ConstStr255Param defaultName,
  166. ;                 StandardFileReply *reply)
  167. ;    = {0x3F3C,0x0005,0xA9EA}; 
  168. (deftrap StandardPutFile ("3f3c" "0005" "a9ea")
  169.   ((prompt address)
  170.    (defaultName address)
  171.    (reply address))
  172.   nil)
  173.  
  174. ; pascal OSErr FSpGetFInfo(const FSSpec *spec,FInfo *fndrInfo)
  175. ;  = {0x303C,0x0007,0xAA52}; 
  176. (deftrap FSpGetFInfo ("303c" "0007" "aa52")
  177.   ((spec address)
  178.    (fndrInfo address))
  179.   short)
  180.  
  181. (defconst sizeof-StandardFileReply 88)
  182. (defun StandardFileReply-sfGood (s) (extract-internal s 0 'char))
  183. (defun StandardFileReply-sfFile (s) (extract-internal s 6 'string (c:sizeof 'FSSpec)))
  184. (defconst sizeof-SFTypeList 16)
  185.  
  186. (defun PutFile (prompt defaultName)
  187.   (let ((reply (make-string sizeof-StandardFileReply 0)))
  188.     (StandardPutFile (CtoPstr prompt) (CtoPstr defaultName) reply)
  189.     (if (zerop (StandardFileReply-sfGood reply))
  190.     nil
  191.       (FSSpec-to-unix-filename (StandardFileReply-sfFile reply)))))
  192.  
  193. ; pascal void StandardGetFile(FileFilterProcPtr fileFilter,
  194. ;                 short numTypes,
  195. ;                 SFTypeList typeList,
  196. ;                 StandardFileReply *reply)
  197. ;    = {0x3F3C,0x0006,0xA9EA}; 
  198. (deftrap StandardGetFile ("3f3c" "0006" "a9ea")
  199.   ((fileFilter address)
  200.    (numTypes short)
  201.    (typeList address)
  202.    (reply address))
  203.   nil)
  204.  
  205. (defun GetFile ()
  206.   (let ((typeList (make-string sizeof-SFTypeList 0))
  207.     (reply (make-string sizeof-StandardFileReply 0)))
  208.     (encode-internal typeList 0 'string "TEXT")
  209.     (StandardGetFile 0 1 typeList reply)
  210.     (if (zerop (StandardFileReply-sfGood reply))
  211.     nil
  212.       (FSSpec-to-unix-filename (StandardFileReply-sfFile reply)))))
  213.  
  214. ; #pragma parameter __D0 StripAddress(__D0)
  215. ; pascal Ptr StripAddress(void *theAddress)
  216. ;    = 0xA055; 
  217. (deftrap StripAddress ("a055")
  218.   ((theAddress address d0))
  219.   (long d0))
  220.  
  221. ; pascal PicHandle GetPicture(short pictureID)
  222. ;     = 0xA9BC; 
  223. (deftrap GetPicture ("a9bc")
  224.   ((pictureID short))
  225.   long)
  226.  
  227. (deftrap a5 ("200d") ; move.l a5,d0
  228.   nil
  229.   (long d0))
  230.  
  231. (defun screenBits ()
  232.   (- (deref (a5)) 122))
  233.  
  234. (deftrap TickCount ("2038" "016a") ; move.l 0x16a,d0
  235.   nil
  236.   (long d0))
  237.  
  238. ; #define GetDblTime() (* (unsigned long*) 0x02F0)
  239. (deftrap GetDblTime ("2038" "02f0") ; move.l 0x2f0,d0
  240.   nil
  241.   (long d0))
  242.  
  243. (deftrap BitClr ("a85f")
  244.   ((bytePtr address)
  245.    (bitnum long))
  246.   nil)
  247.